package Webpacus::Model::WebPAC;

use strict;
use warnings;
use lib '/data/webpac2/lib';
use base qw/
	Catalyst::Model
/;
use WebPAC::Store 0.08;
use Search::Estraier 0.04;
use File::Slurp;
use Time::HiRes qw/time/;
use Encode qw/encode decode from_to/;
use Template;

=head1 NAME

Webpacus::Model::WebPAC - Catalyst Model

=head1 SYNOPSIS

See L<Webpacus> and L<WebPAC>.

=head1 DESCRIPTION

Catalyst Model for access to WebPAC data.

=head2 new

Configuration for hyperestraier in C<config.yaml> like this:

 --- #YAML:1.0
 # DO NOT USE TABS FOR INDENTATION OR label/value SEPARATION!!!

 # configuration for hyper estraier full text search engine
 hyperestraier:
  masterurl: 'http://localhost:1978/node/webpac2'
  defaultnode: 'webpac2'
  defaultdepth: 1
  user: 'admin'
  passwd: 'admin'
  hits_on_page: 100
  hits_for_pager: 1000

 webpac:
  db_path: '/data/webpac2/db'
  template_path: '/data/webpac2/conf/output/tt'
  template: 'html_ffzg_results_short.tt'
  # encoding comming from webpac
  webpac_encoding: 'iso-8859-2'

=cut

sub new {
	my ( $self, $c, $config ) = @_;

	$self = $self->NEXT::new($c, $config);
	$self->config($config);

	my $log = $c->log;
	$self->{log} = $log;

	my $est_cfg = $c->config->{hyperestraier};
	$est_cfg->{'log'} = $log;

	$est_cfg->{encoding} = $est_cfg->{catalyst_encoding} || $c->config->{catalyst_encoding} or $c->log->fatal("can't find catalyst_encoding");

	$log->dumper($est_cfg, 'est_cfg');

	if (! $est_cfg->{database}) {
		my $defaultnode = $est_cfg->{defaultnode} || $log->logdie("can't find defaultnode in estraier configuration");
		$log->info("using default node $defaultnode");
		$est_cfg->{database} = $defaultnode;
	}

	my $url = $est_cfg->{masterurl} . '/node/' . $est_cfg->{database};

	$log->info("opening Hyper Estraier index $url as $est_cfg->{'user'}");

	$self->{est_node} = Search::Estraier::Node->new(
		url => $url,
		user => $est_cfg->{user},
		passwd => $est_cfg->{passwd},
	);

	$log->fatal("can't create Search::Estraier::Node $url") unless ($self->{est_node});

	# save config parametars in object
	foreach my $f (qw/
		db_path template_path hits_on_page webpac_encoding defaultdepth
		masterurl defaultnode
		/) {
		$self->{$f} = $c->config->{hyperestraier}->{$f} ||
			$c->config->{webpac}->{$f};
		$log->debug("self->{$f} = " . $self->{$f});
	}
	my $db_path = $self->{db_path};
	my $template_path = $self->{template_path};

	$log->debug("using db path '$db_path', template path '$template_path'");

	$self->{db} = new WebPAC::Store(
		path => $db_path,
		read_only => 1,
		database => $est_cfg->{database},
	);

	# default template from config.yaml
	$self->{template} ||= $c->config->{webpac}->{template};

	$log->debug("converting encoding from webpac_encoding '" .
		$c->config->{webpac}->{webpac_encoding} .
		"'"
	);

	$self->{databases} = $c->config->{databases} || $log->fatal("can't find databases in config");

	# create Template toolkit instance
	$self->{'tt'} = Template->new(
		INCLUDE_PATH => $template_path,
		FILTERS => {
			dump_html => sub {
				return unless (@_);
				my $out;
				my $i = 1;
				foreach my $v (@_) {
					$out .= qq{<div id="dump_$i">} .
						Data::HTMLDumper->Dump([ $v ],[ "v$i" ]) .
						qq{</div>};
					$i++;
				}
				$out =~ s!<table[^>/]*>!<table class="dump">!gis if ($out);
				return $out;
			}
		},
		EVAL_PERL => 1,
	);

	return $self;

}

=head2 setup_site

 $self->setup_site('site_name');

Change node URL and database name according to site name (if available) or fallback
to C<defaultnode> from configuration.

=cut

sub setup_site {
	my $self = shift;

	my $site = shift || $self->{defaultnode};
	if (! $site) {
		$self->{log}->warn("not changing site from " . $self->{est_node}->{url});
		return;
	}

	$self->{log}->fatal("setup_site can't find site or defaultnode") unless ($site);

	my $url = $self->{masterurl} . '/node/' . $site;
	$self->{est_node}->set_url( $url );
	$self->{log}->debug("setup_site '$site' using $url");
}

=head2 search

  my $m->search(
  	phrase => 'query phrase',
	add_attr => \@add_attr
	get_attr => [ '@uri' ],
	hits_on_page => 42,
	template => 'result_template.tt',
	depth => 1,
  );

All fields are standard C<WebPAC::Search::Estraier> parametars except
C<template> which will (if specified) return results in HTML using
selected template.

=cut

sub search {
	my $self = shift;

	my $search_start_t = time();

	my $args = {@_};

	my $log = $self->{log};

	$log->dumper($args, 'args');

	my $query = $args->{phrase} || $log->warn("no query phrase") && return;

	my $template_filename = $args->{template} || $self->{template};

	$args->{hits_on_page} ||= $self->{'hits_for_pager'};
	if (! $args->{hits_on_page}) {
		$args->{hits_on_page} = 100;
		$log->warn("hints_on_page not set when calling model. Using default of $args->{hits_on_page}");
	}

	my $times;	# store some times for benchmarking

	my $t = time();

	# transfer depth of search
	if (! $args->{depth}) {
		my $default = $self->{defaultdepth} || $log->logdie("can't find defaultdepth in estraier configuration");
		$args->{depth} = $default;
		$log->warn("using default search depth $default");
	}
	$args->{depth} ||= 0;

	$log->debug("searching " . $self->{est_node}->{url} . " hits on page: $args->{hits_on_page} depth: $args->{depth} phrase: " . ($query || '[none]') );

	#
	# construct condition for Hyper Estraier
	#
	my $cond = Search::Estraier::Condition->new();
	if ( ref($args->{add_attr}) eq 'ARRAY' ) {
		$log->debug("adding search attributes: " . join(", ", @{ $args->{add_attr} }) );
		map {
			$cond->add_attr( $_ );
			$log->debug(" + $_");
		} @{ $args->{add_attr} };
	};

	$cond->set_phrase( $query ) if ($query);
	$cond->set_options( $args->{options} ) if ($args->{options});
	$cond->set_order( $args->{order} ) if ($args->{order});

	my $hits_on_page = $args->{hits_on_page} || 7;
	my $page = $args->{page} || 1;
	if ($page < 1) {
		$log->warn("page number $page < 1");
		$page = 1;
	}

	$cond->set_max( my $max = $page * $hits_on_page );
	$cond->set_skip( my $skip = ( $page - 1 ) * $hits_on_page );

	$log->debug("search max: $max, skip: $skip");

	my $result = $self->{est_node}->search($cond, $args->{depth});
	if (! $result) {
		$self->{log}->fatal("search didn't return result");
		return;
	}
	my $hits = $result->doc_num;

	$times->{est} += time() - $t;

	$log->debug( sprintf("search took %.6fs and returned $hits hits.", $times->{est}) );

	$self->{hints} = $result->{hints};
	#$log->dumper($self->{hints}, 'original hints' );

	#
	# fetch results
	#

	my @results;

	

	for my $i ( 0 .. ( $hits < $max ? ($hits-1) : ($max-1) ) ) {

		$t = time();

		#$log->debug("get_doc($i)");
		my $doc = $result->get_doc( $i );
		if (! $doc) {
			$log->warn("can't find result $i");
			next;
		}

		my $hash;

		foreach my $attr (@{ $args->{get_attr} }) {
			my $val = $doc->attr( $attr );
			#$log->debug("attr $attr = ", $val || 'undef');
			$hash->{$attr} = $val if (defined($val));
		}

		$times->{hash} += time() - $t;

		next unless ($hash);

		if (! $args->{'template'}) {
			push @results, $hash;
		} else {
			my ($database, $prefix, $id);

			if ( $hash->{'@uri'} =~ m!/([^/]+)/([^/]+)/(\d+)$!) {
				($database, $prefix,$id) = ($1,$2,$3);
			} else {
				$log->warn("can't decode database/prefix/id from " .  $hash->{'@uri'});
				next;
			}

			#$log->debug("load_ds( id => $id, prefix => '$prefix' )");

			$t = time();

			my $ds = $self->{db}->load_ds( database => $database, prefix => $prefix, id => $id );
			if (! $ds) {
				$log->error("can't load_ds( ${database}/${prefix}/${id} )");
				next;
			}

			$times->{db} += time() - $t;

			$t = time();

			my $html = $self->apply(
				template => $template_filename,
				data => $ds,
				record_uri => "${database}/${prefix}/${id}",
				config => $self->{databases}->{$database},
			);

			$times->{apply} += time() - $t;

			$t = time();

			$html = decode($self->{webpac_encoding}, $html);

			$times->{decode} += time() - $t;

			push @results, $html;
		}

	}

	$log->debug( sprintf(
		"duration breakdown: estraier %.6fs, hash %.6fs, store %.6fs, apply %.6fs, decode %.06f, total: %.6fs",
		$times->{est}, $times->{hash}, $times->{db}, $times->{apply}, $times->{decode}, time() - $search_start_t,
	) );

	return \@results;
}

=head2 hints

  my $hints = $m->hints;

Return various useful hints about result

=cut

sub hints {
	my $self = shift;

	unless ($self->{hints}) {
		$self->{log}->fatal("no hints found!");
		return;
	}

	my $hints;

	while (my ($key,$val) = each %{ $self->{hints} }) {

		#$self->{log}->debug("current hint $key = $val");

		if ($key =~ m/^(?:HITS*|TIME|DOCNUM|WORDNUM)$/) {
			$hints->{ lc($key) } = $val;
		} elsif ($key =~ m/^HINT#/) {
			my ($word,$count) = split(/\t/,$val,2);
			$hints->{words}->{$word} = $count;
		} elsif ($key =~ m/^LINK#/) {
			my ($url,undef,undef,undef,undef,undef,$results) = split(/\t/,$val,7);
			if ($url =~ m#/node/(.+)$#) {
				$hints->{node}->{$1} = $results;
			} else {
				$self->{log}->debug("url $url doesn't have /node/ in it!");
			}
		} else {
			$self->{log}->debug("unknown hint $key = $val");
		}

	}

	$self->{log}->dumper($hints, 'model hints' );

	return $hints;
}


=head2 record

  my $html = $m->record(
  	mfn => 42,
	template => 'foo.tt',
  );

This will load one record, convert it to html using C<template> and return
it.

=cut

sub record {
	my $self = shift;

	my $args = {@_};
	my $log = $self->{log};
	$log->dumper( $args, 'args' );

	foreach my $f (qw/record_uri template/) {
		$log->fatal("need $f") unless ($args->{$f});
	}

	my ($database, $prefix, $id);

	if ($args->{record_uri} =~ m#^([^/]+)/([^/]+)/([^/]+)$#) {
		($database, $prefix, $id) = ($1,$2,$3);
	} else {
		$log->error("can't parse $args->{record_uri} into prefix, database and uri");
		return;
	}

	my $ds = $self->{db}->load_ds( id => $id, prefix => $prefix, database => $database );
	if (! $ds) {
		$log->error("can't load_ds( $database/$prefix/$id )");
		return;
	}

	my $html = $self->apply(
		template => $args->{template},
		data => $ds,
		record_uri => $args->{record_uri},
		config => $self->{databases}->{$database},
	);

	$html = decode($self->{webpac_encoding}, $html);

	return $html;
}


=head2 list_nodes

  my @nodes = $m->list_nodes( 'site' );

Return all databases which have records for selected site. Returned array of
hashes has elements C<name> and C<label>.

This function does cacheing inside C<< $self->{nodes_in_site} >>, but you
probably didn't want to know that.

=cut

sub list_nodes {
	my $self = shift;

	my $site = shift || $self->{defaultnode};

	# cache?
	if ($self->{nodes_in_site}->{$site} && ref($self->{nodes_in_site}->{$site}) eq 'ARRAY') {
		$self->{log}->debug("list_nodes for site $site and returns from cache");
		return @{ $self->{nodes_in_site}->{$site} };
	};

	$self->{log}->debug("list_nodes for site $site");

	$self->setup_site( $site );

	my @nodes;

	if ($self->{est_node}->doc_num > 0) {
		push @nodes, {
			name => $self->{est_node}->name,
			label => $self->{est_node}->label,
			doc_num => $self->{est_node}->doc_num,
		}
	}

	# refresh set info
	$self->{est_node}->_set_info;

	my $links = $self->{est_node}->links || return @nodes;

	$self->{log}->dumper( $links, 'links' );

	foreach my $link (@{ $links }) {
		my ($url, $label, $credit) = split(/\t/, $link, 3);
		if ($url =~ m#/node/(.+)$#) {
			my $node = $1;
			$self->setup_site( $node );
			$self->{est_node}->_set_info;
			$label = decode('UTF-8', $label);
			push @nodes, {
				name => $node,
				label => $label,
				doc_num => $self->{est_node}->doc_num,
			}
		} else {
			$self->{log}->warn("can't find node name in link $link");
		}
	}

	$self->setup_site( $site );
	$self->{est_node}->_set_info;

	$self->{nodes_in_site}->{$site} = \@nodes;

	return @nodes;
}

=head2 save_html

  $m->save_html( '/full/path/to/file', $content );

It will use C<Encode> to convert content encoding back to
Webpac codepage, recode JavaScript Unicode entities (%u1234),
strip extra newlines at beginning and end, and save to 
C</full/path/to/file.new> and if that succeeds, just rename
it over original file which should be atomic on filesystem level.

=cut

sub save_html {
	my ($self, $path, $content) = @_;

	# FIXME Should this be UTF-8 or someting?
	my $js_encoding = $self->{webpac_encoding};
	$js_encoding = 'UTF-16';

	sub _conv_js {
		return '0x' . $_[1];
		return encode($_[0], chr(hex($_[1])));
	}
	#$content =~ s/%u([a-fA-F0-9]{4})/_conv_js($js_encoding,$1)/gex;
	$content =~ s/^[\n\r]+//s;
	$content =~ s/[\n\r]+$/\n/s;
	$content =~ s/\n\r/\n/gs;

	my $disk_encoding = $self->{webpac_encoding} || 'utf-8';
	$self->{log}->debug("convert encoding to $disk_encoding");
	from_to($content, 'utf-8', $disk_encoding) || $self->{log}->warn("encoding from utf-8 to $disk_encoding failed for: $content");

	write_file($path . '.new', {binmode => ':raw' }, $content) || die "can't save ${path}.new $!";
	rename $path . '.new', $path || die "can't rename to $path: $!";
}

=head2 load_html

  my $html = $m->load_html('/full/path/to/file');

This will convert file from Webpac encoding to Catalyst and
convert that data to escaped HTML (for sending into
C<< <textarea/> >> tags in html.

=cut

sub load_html {
	my ($self, $path) = @_;

	die "no path?" unless ($path);

	my $content = read_file($path, {binmode => ':raw' }) || die "can't read $path: $!";

	return decode($self->{webpac_encoding}, $content);
}


=head2 apply

Create output from in-memory data structure using Template Toolkit template.

 my $text = $tt->apply(
 	template => 'text.tt',
	data => $ds,
	record_uri => 'database/prefix/mfn',
 );

It also has follwing template toolikit filter routies defined:

=cut

# Escape <, >, & and ", and to produce valid XML
my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');  
my $escape_re  = join '|' => keys %escape;

sub apply {
	my $self = shift;

	my $args = {@_};

	my $log = $self->{log} || die "no log?";

	foreach my $a (qw/template data/) {
		$log->fatal("need $a") unless ($args->{$a});
	}

=head3 tt_filter_type

filter to return values of specified from $ds, usage from TT template is in form
C<d('FieldName','delimiter')>, where C<delimiter> is optional, like this:

  [% d('Title') %]
  [% d('Author',', ' %]

=cut

	sub tt_filter_type {
		my ($data,$type) = @_;
		
		die "no data?" unless ($data);
		$type ||= 'display';

		my $default_delimiter = {
			'display' => '&#182;<br/>',
			'index' => '\n',
		};

		return sub {

			my ($name,$join) = @_;

			die "no data hash" unless ($data->{'data'} && ref($data->{'data'}) eq 'HASH');
			# Hm? Should we die here?
			return unless ($name);

			my $item = $data->{'data'}->{$name} || return;

			my $v = $item->{$type} || return;

			if (ref($v) eq 'ARRAY') {
				if ($#{$v} == 0) {
					$v = $v->[0];
					$v =~ s/($escape_re)/$escape{$1}/g;
				} else {
					$join = $default_delimiter->{$type} unless defined($join);
					$v = join($join, map {
						s/($escape_re)/$escape{$1}/g;
					} @{$v});
				}
			} else {
				warn("TT filter $type(): field $name values aren't ARRAY, ignoring");
			}

			return $v;
		}
	}

	$args->{'d'} = tt_filter_type($args, 'display');
	$args->{'display'} = tt_filter_type($args, 'display');

=head3 tt_filter_search

filter to return links to search, usage in TT:

  [% search('FieldToDisplay','FieldToSearch','optional delimiter', 'optional_template.tt') %]

=cut

	sub tt_filter_search {

		my ($data) = @_;

		die "no data?" unless ($data);
		
		return sub {

			my ($display,$search,$delimiter,$template) = @_;
			
			# default delimiter
			$delimiter ||= '&#182;<br/>',

			die "no data hash" unless ($data->{'data'} && ref($data->{'data'}) eq 'HASH');
			# Hm? Should we die here?
			return unless ($display);

			my $item = $data->{'data'}->{$display} || return;

			return unless($item->{'display'});
			if (! $item->{'search'}) {
				warn "error in TT template: field $display didn't insert anything into search, use d('$display') and not search('$display'...)";
				return;
			}

			my @warn;
			foreach my $type (qw/display search/) {
				push @warn, "field $display type $type values aren't ARRAY" unless (ref($item->{$type}) eq 'ARRAY');
			}

			if (@warn) {
				warn("TT filter search(): " . join(",", @warn) . ", skipping");
				return;
			}
			my @html;

			my $d_el = $#{ $item->{'display'} };
			my $s_el = $#{ $item->{'search'} }; 

			# easy, both fields have same number of elements or there is just
			# one search and multiple display
			if ( $d_el == $s_el || $s_el == 0 ) {

				foreach my $i ( 0 .. $d_el ) {

					my $s;
					if ($s_el > 0) {
						$s = $item->{'search'}->[$i];
					} else {
						$s = $item->{'search'}->[0];
					}

					next unless (defined($s) && $s ne '');

					#$s =~ s/([^\w.-])/sprintf("%%%02X",ord($1))/eg;
					$s = __quotemeta( $s );

					my $d = $item->{'display'}->[$i];

					next unless (defined($d) && $d ne '');

					my $template_arg = '';
					$template_arg = qq{,'$template'} if ($template);

					push @html, qq{<a href="#" onclick="return search_via_link('$search','$s'${template_arg})">$d</a>};
				}

				return join($delimiter, @html);
			} else {
				my $html = qq{<div class="notice">WARNING: we should really support if there is $d_el display elements and $s_el search elements, but currently there is no nice way to do so, so we will just display values</div>};
				my $v = $item->{'display'};

				if ($#{$v} == 0) {
					$html .= $v->[0];
				} else {
					$html .= join($delimiter, @{$v});
				}
				return $html;
			}
		}
	}

	$args->{'search'} = tt_filter_search($args);

=head3 load_rec

Used mostly for onClick events like this:

  <a href="#" onClick="[% load_rec( record_uri, 'template_name.tt') %]>foo</a>

It will automatically do sanity checking and create correct JavaScript code.

=cut

	$args->{'load_rec'} = sub {
		my @errors;

		my $record_uri = shift or push @errors, "record_uri missing";
		my $template = shift or push @errors, "template missing";

		if ($record_uri !~ m#^[^/]+/[^/]+/[^/]+$#) {
			push @errors, "invalid format of record_uri: $record_uri";
		}

		if (@errors) {
			return "Logger.error('errors in load_rec: " . join(", ", @errors) . "'); return false;";
		} else {
			return "load_rec('$record_uri','$template'); return false;";
		}
	};

=head3 load_template

Used to re-submit search request and load results in different template

  <a href="#" onClick="[% load_template( 'template_name.tt' ) %]">bar</a>

=cut

	$args->{'load_template'} = sub {
		my $template = shift or return "Logger.error('load_template missing template name!'); return false;";
		return "load_template($template); return false;";
	};

	my $out;

	$self->{'tt'}->process(
		$args->{'template'},
		$args,
		\$out
	) || $log->error( "apply can't process template: ", $self->{'tt'}->error() );

	return $out;
}


=head2 __quotemeta

Helper to quote JavaScript-friendly characters

=cut

sub __quotemeta {
	local $_ = shift;
	$_ = decode('iso-8859-2', $_);

	s<([\x{0080}-\x{fffd}]+)>{sprintf '\u%0*v4X', '\u', $1}ge if ( Encode::is_utf8($_) );
	{
		use bytes;  
		s<((?:[^ \x21-\x7E]|(?:\\(?!u)))+)>{sprintf '\x%0*v2X', '\x', $1}ge;
	}

	s/\\x09/\\t/g;
	s/\\x0A/\\n/g;
	s/\\x0D/\\r/g;
	s/"/\\"/g;
	s/\\x5C/\\\\/g;

	return $_;
}



=head1 AUTHOR

Dobrica Pavlinusic C<< <dpavlin@rot13.org> >>

=head1 LICENSE

This library is free software, you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut

1;
